unit frmMainUnit;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  Vcl.StdCtrls, GeneticAlgs, Vcl.ExtCtrls, VCLTee.TeEngine, VCLTee.Series,
  VCLTee.BubbleCh, VCLTee.TeeProcs, VCLTee.Chart, System.Math, Vcl.ComCtrls,
  Xml.XMLIntf, Xml.XMLDoc;

type
  TfrmMain = class(TForm)
    btStart: TButton;
    Timer: TTimer;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    Chart1: TChart;
    Series1: TPointSeries;
    Memo1: TMemo;
    Series2: TPointSeries;
    tbMutation: TTrackBar;
    tbCrossover: TTrackBar;
    Label1: TLabel;
    Label2: TLabel;
    tbGoal: TTrackBar;
    btCataclysms: TButton;
    Label3: TLabel;
    tbReInit: TTrackBar;
    Label4: TLabel;
    PaintBox: TPaintBox;
    procedure btStartClick(Sender: TObject);
    procedure TimerTimer(Sender: TObject);
    procedure btCataclysmsClick(Sender: TObject);
    procedure tbGoalChange(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure PaintBoxPaint(Sender: TObject);
  private
    FEvolution: TBinaryEvolution<Cardinal>;
    FBaseEvals: Integer;
    FGoal:      Cardinal;
  protected
    function  GetBit(C: Cardinal; AIndex: Integer): Boolean;
    function  ToBinStr(C: Cardinal): string;
    function  Fitness(C: Cardinal): Double;
    function  Error(C: Cardinal): Double;
    procedure UpdateEdits;
    procedure UpdateCharts;
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}

procedure TfrmMain.btStartClick(Sender: TObject);
var
  fitness: TFunc<Cardinal, Double>;
  pstinit: TPostInitProc<Cardinal>;
  mutate:  TMutate<Cardinal>;
begin
  if FEvolution = nil then
  begin
    FBaseEvals := 0;
    Edit2.Text := '';
    Edit3.Text := '';
    Edit4.Text := '';
    Series1.Clear;
    Series2.Clear;

    fitness := function(V: Cardinal): Double
               begin
                 Result := Self.Fitness(V);
               end;
    pstinit := procedure(var V: Cardinal)
               begin
//                 PByte(@V)[3] := PByte(@V)[3] or not ($FF shr 2);
               end;
    mutate  := procedure(var V: Cardinal; var AHandled: Boolean)
               begin
//                 V := V + Round(GRandom * $FF);
//                 AHandled := True;
               end;

    FEvolution := TBinaryEvolution<Cardinal>.Create(500, fitness);
    FEvolution.OnPostInit       := pstinit;
    FEvolution.OnMutate         := mutate;
    FEvolution.SelectionKind    := skUniform;
    FEvolution.ReplacementKind  := rkTour;
    FEvolution.IncestPrevention := 5;
    FEvolution.MutationKind     := mkSingleBit;
    FEvolution.CrossoverKind    := ckOnePoint;
  end
  else
    FreeAndNil(FEvolution);
end;

procedure TfrmMain.TimerTimer(Sender: TObject);
const
  STEPS = 10;
var
  i: Integer;
begin
  if FEvolution <> nil then
  begin
    FEvolution.MutationProbability  := tbMutation.Position / 100;
    FEvolution.CrossoverProbability := tbCrossover.Position / 100;
    FEvolution.ReInitPropbability   := tbReInit.Position / 100;

    for i := 0 to STEPS - 1 do
    begin
      FEvolution.Step;
      UpdateCharts;
      UpdateEdits;
    end;

    Chart1.Refresh;
    PaintBox.Refresh;
  end;
end;

function TfrmMain.ToBinStr(C: Cardinal): string;
const
  DIGITS: array[Boolean] of Char = ('0', '1');
var
  i, bits: Integer;
begin
  bits := SizeOf(Cardinal) * 8;
  SetLength(Result, bits);

  for i := 0 to bits - 1 do
    Result[bits - i] := DIGITS[GetBit(C, i)];
end;

procedure TfrmMain.btCataclysmsClick(Sender: TObject);
begin
  if FEvolution <> nil then
    FEvolution.Cataclysm;
end;

function TfrmMain.Error(C: Cardinal): Double;
begin
  Result := Abs(Int64(C) - Int64(FGoal));// / 4294967295 * 100;
end;

function TfrmMain.Fitness(C: Cardinal): Double;
begin
  Result := -Abs(Int64(FGoal) - Int64(C));
end;

procedure TfrmMain.FormCreate(Sender: TObject);
var
  xml: IXmlDocument;
  nd:  IXMLNode;
begin
  if FileExists('Settings.xml') then
  begin
    xml         := TXMLDocument.Create('Settings.xml');
    xml.Active  := True;
    nd          := xml.ChildNodes['settings'];

    tbGoal.Position      := nd['goal'];
    tbMutation.Position  := nd['mutation-p'];
    tbCrossover.Position := nd['crossover-p'];
    tbReInit.Position    := nd['reinit-p'];
  end;

  tbGoalChange(tbGoal);
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
var
  xml: IXmlDocument;
  nd:  IXMLNode;
begin
  xml         := TXMLDocument.Create(nil);
  xml.Options := xml.Options + [doNodeAutoIndent];
  xml.Active  := True;
  nd          := xml.ChildNodes['settings'];

  nd['goal']        := tbGoal.Position;
  nd['mutation-p']  := tbMutation.Position;
  nd['crossover-p'] := tbCrossover.Position;
  nd['reinit-p']    := tbReInit.Position;

  xml.SaveToFile('Settings.xml');
end;

function TfrmMain.GetBit(C: Cardinal; AIndex: Integer): Boolean;
begin
  Result := (C and (1 shl AIndex)) <> 0;
end;

procedure TfrmMain.PaintBoxPaint(Sender: TObject);
const
  DIGITS: array[Boolean] of Char = ('0', '1');
  CLRS:   array[Boolean] of TColor = (clRed, clBlack);
var
  i, j:    Integer;
  bits:    Integer;
  w:       Double;
  r:       TRect;
  sz:      TSize;
  bt:      Integer;
  s:       string;
  distr:   array[0..31] of Double;
begin
  if FEvolution <> nil then
  begin
    bits := 32;

    { Calc distribution }

    for i := 0 to bits - 1 do
    begin
      distr[i] := 0;
      for j := 0 to FEvolution.PopulationSize - 1 do
      begin
        if {GetBit(FGoal, i) =} GetBit(FEvolution[j].Value, i) then
          distr[i] := distr[i] + 1;
      end;

      distr[i] := 0.5 - Abs(distr[i] / FEvolution.PopulationSize - 0.5);
    end;

    { Draw }

    w := PaintBox.Width / bits;

    for i := 0 to bits - 1 do
    begin
      r  := Rect(Round(i * w), 0, Round((i + 1) * w), PaintBox.Height);
      bt := bits - 1 - i;

      PaintBox.Canvas.Brush.Color := clBtnFace;
      PaintBox.Canvas.Font.Color  := CLRS[GetBit(FGoal, bt) = GetBit(
                                          FEvolution.Best, bt)];

      s  := DIGITS[GetBit(FGoal, bt)];
      sz := PaintBox.Canvas.TextExtent(s);
      PaintBox.Canvas.TextOut(r.CenterPoint.X - sz.cx div 2, 5, s);

      s  := DIGITS[GetBit(FEvolution.Best, bt)];
      sz := PaintBox.Canvas.TextExtent(s);
      PaintBox.Canvas.TextOut(r.CenterPoint.X - sz.cx div 2, 25, s);

      r.Top := 45;
      PaintBox.Canvas.Brush.Color := RGB(Round(distr[bt] * 255 * 2), 0, 0);
      PaintBox.Canvas.FillRect(r);

      s  := Format('%d%%', [Round(distr[bt] * 100)]);
      sz := PaintBox.Canvas.TextExtent(s);
      PaintBox.Canvas.Font.Color := clWhite;
      PaintBox.Canvas.TextOut(r.CenterPoint.X - sz.cx div 2, 53, s);
    end;
  end;
end;

procedure TfrmMain.tbGoalChange(Sender: TObject);
begin
  FGoal := $FFFFFFFF - Round(tbGoal.Position / 100 * $FFFFFFFF);

  if FEvolution <> nil then
  begin
    FEvolution.ReevalAll;
    FBaseEvals := FEvolution.Evaluations;
    Edit2.Text := '';
  end;
end;

procedure TfrmMain.UpdateEdits;
var
  best: Cardinal;
  err:  Double;
begin
  best := FEvolution.Best;
  err  := Error(best);

  Edit1.Text := Format('%d: %u (%.4e%%)', [FEvolution.Evaluations -
                                           FBaseEvals, best, err]);
  if (Edit2.Text = '') and (err = 0) then
    Edit2.Text := Edit1.Text;
  Edit3.Text := Format('Goal: %s', [ToBinStr(FGoal)]);
  Edit4.Text := Format('Best: %s', [ToBinStr(best)]);
end;

procedure TfrmMain.UpdateCharts;
var
  i: Integer;
begin
  Series1.BeginUpdate;
  Series2.BeginUpdate;
  try
    Chart1.LeftAxis.SetMinMax(0, $FFFFFFFF);
    Chart1.BottomAxis.SetMinMax(Max(FEvolution.Generations - 50, 0),
                                FEvolution.Generations);

    for i := 0 to FEvolution.PopulationSize - 1 do
      Series1.AddXY(FEvolution.Generations + Random, FEvolution[i].Value);
    Series2.AddXY(FEvolution.Generations, FGoal, '', clRed);
  finally
    Series2.EndUpdate;
    Series1.EndUpdate;
  end;
end;

end.

